perm filename PLTCMX.F4[MSS,LCS]2 blob sn#107258 filedate 1974-06-16 generic text, type T, neo UTF8
00100	C**** PLTCMD, FILLMS, ROTATE  *********
38800		SUBROUTINE PLTCMD
38900	CC	IMPLICIT INTEGER(A-Q,S-Z)
39000		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
39100		DIMENSION NMS(8),RMOV1(8),RMOV2(8)
39200		COMMON /DL/X22,SAVER,NAME /ALF/INP(3),ML
39400		COMMON RJB,JE,CENTR,JB,RJQ(20),JQ(20)
39700		EQUIVALENCE (RJE,RJQ(3)),(RJF,RJQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
39800		1,(RJC,RJQ(1)),(I2,INP(2)),(RJH,RJQ(6)),(I3,INP(3))
39950		F78F(1)='(78F)'
39960		FA5(1)='(A5) '
39970		FA1(1)='(A1) '
40000	
40100		IF(I2.NE.'X')GO TO 1
40150	CC	ML=' '
40200		I2=0
40300		RXC=0
40400		RMOV1(1)='Y'
40500		NAME=0
40600	14	KA=0
40700	3	KA=KA+1
40710	CC	IF(ML.EQ.' ')GO TO 15
40715		IF(ML.EQ.0)GO TO 15
40720		K=K-2
40725		ML=ML-1
40730		IF(ML.EQ.0)GO TO 10
40740		GO TO 31
40800	15	TYPE 2,KA
40900		ACCEPT 11,K,ML
40950	C  TYPE LAST NAME, NUMBER  FOR A SERIES
41000	50	IF(K.EQ.' ')GO TO 10
41100		IF(K.EQ.'99')GO TO 140
41200	C  99=BACKUP
41300	31	IF(LOOKD(K))GO TO 56
41400	C JUMP IF FILE FOUND
41500		TYPE 55
41600		GO TO 15
41700	55	FORMAT(' FILE NOT FOUND'/)
41750	11	FORMAT(A5,I)
41800	56	NMS(KA)=K
41810	CC	IF(ML.EQ.' ')GO TO 5
41820		IF(ML.EQ.0)GO TO 5
41855		RJH='Y'
41877		GO TO 21
41900	5	TYPE 8
42000		ACCEPT FA5,RJH
42100		IF(RJH.EQ.'99')GO TO 15
42200		IF(RJH.NE.'Y')RJH=0
42300		IF(RJH.EQ.0)REREAD F78F,RJH
42400	C  MOVE NUMBER CAN BE TYPED FOR 'MOVE UP'
42500	21	RMOV1(KA+1)=RJH
42600		RMOV2(KA)=RJH
42700		GO TO 3
42800	140	KA=KA-1
42900		GO TO 15
43000	
43100	10	KB=KA-1
43110		IF(I3.NE.'G')GO TO 22
43120		RSIZ=1
43130		GO TO 222
43200	22	TYPE 9
43300		ACCEPT F78F,RSIZ
43400		IF(RSIZ.EQ.99.OR.RSIZ.EQ.0)GO TO 5
43500	222	KA=0
43600	
43700	1	IF(NAME.NE.0)GO TO 12
43800		IF(KA.EQ.KB)CALL PLOT(0,0,99)
43900		NAME=NMS(KA+1)
44000		TYPE 111,NAME
44100		RETURN
44200	12	KA=KA+1
44300		NAME=0
44400		RJD=1
44500		IF(INP(3).EQ.'C')RJD=0
44600	C  'PXC' = CALCOMP OUTPUT
44700		RJH=0
44800		RJB=RSIZ
44900		RJC=RSIZ
45000		RJG=0
45100		RJE=1
45200		RJF=1
45300		IF(RMOV2(KA).NE.'Y')RJG=RMOV2(KA)
45400		IF(RMOV1(KA).NE.0)RJE=0
45500		IF(RMOV2(KA).NE.0.OR.RJG.NE.0)RJF=0
45600	2	FORMAT(' TYPE FILE NAME',I2,1X$)
45700	8	FORMAT(' MOVE UP AT END? ',$)
45800	9	FORMAT(' SIZE FACTOR? ',$)
45900	111	FORMAT(1XA5/)
46000		END
60800	
62000	
63500	
65000	C******   CHANGE 3, 4 AND 5 TO JFCL IN DDT WHEN USING DISTORTION.(SEE 'LINES')
65100		SUBROUTINE FILLMS(L,IDAT,RJB,CENTR,RJF,RJG)
65200		COMMON/DL/IXRX,SAVER,NAME
65300		COMMON/DST/BB,CC/FLM/X(200),Y(200),NX(200)
65400		DIMENSION IDAT(1)
65500		COMMON/PLTR/IPLT,RHT,DIS/LL/LL/STF/RR(8),RSTJC
65600		DATA MP/2/,MD/6/
65700	C MD=DISPLAY   MP=PLOTTER   MX=XGP
65800		DX=DIS
65900		RX=RHT
66000		D=RSTJC*RJF
66100		R=RSTJC*RJG
66200	4	GO TO 1
66300		C=CC
66400		B=BB
66500	C  SAVES IT.  IT WILL RETURN LATER.
66600		BB=B/DIS
66700		CC=1000
66800	1	KK=0
66900		DO 205 J=1,L
67000		CALL UNPACK(M,N,IDAT(J))
67100		KK=KK+1
67200		NX(KK)=0
67300		IF(LL.EQ.3)NX(KK)=3
67400		X(KK)=ROFF((RJB+D*M)*DIS)
67500		Y(KK)=ROFF((CENTR+R*N)*RHT)
67600	3	GO TO 205
67700		Y(KK)=Y(KK)*(C-BB*(ABS(X(KK))))
67800	C  FOR DISTORTION
67900	205	CONTINUE
68000		NX(1)=KK
68100		DIS=1.0
68200		RHT=DIS
68300		M=MD
68400		IF(IPLT)M=MP-IXRX
68500	C  STOPS DISTORTION IN 'LINES'
68600	2	CALL FILLER(X,Y,NX,M)
68700		DIS=DX
68800		RHT=RX
68900	5	RETURN
69000	C  NEXT TO RESET DISTORTION FACT.
69100		BB=B
69200		CC=C
69300		RETURN
69400		END
69500	
69600		SUBROUTINE ROTATE(I,L)
69700		DIMENSION I(1)
69800		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)/STF/RR(8),RSTJC
69900		EQUIVALENCE (RJF,RJQ(4)),(RJG,RJQ(5)),(DEG,RJQ(7))
70000		RJG=RJG*RSTJC
70100		RJF=RJF*RSTJC
70200		N=I(L)
70300		KNT=501
70400	C  ROTATED DATA IS PUT BACK STARTING AT LOCATION 501.
70500		I(KNT)=N
70600		DO 1 K=L+1,N+L-1
70700		CALL UNPACK(J,M,I(K))
70800		X=J*RJF
70900		Y=M*RJG
71000		JJ=I(K)/100000000
71100		AX=ATAN2(X,Y)*57.29578
71200		HYP=SQRT(X**2+Y**2)
71300		ROT=DEG+AX
71400		J=ROFF(HYP*COSD(ROT))
71500		M=ROFF(HYP*SIND(ROT))
71600		KNT=KNT+1
71700		IF(J)J=1000-J
71800		IF(M)M=1000-M
71900	1	I(KNT)=M*10000+J+JJ*100000000
72000		L=501
72100		RJF=1.
72200		RJG=1.
72300		RSTJC=1.
72400	C  SIZE CHANGES MUST BE MADE BEFORE ROTATION!!!!! ELSE IT DISTORTS.
72500		END